home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-reply.el.z / vm-reply.el
Encoding:
Text File  |  1998-05-21  |  45.1 KB  |  1,253 lines
  1. ;;; Mailing, forwarding, and replying commands for VM
  2. ;;; Copyright (C) 1989-1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-reply)
  19.  
  20. (defun vm-do-reply (to-all include-text count)
  21.     (let ((mlist (vm-select-marked-or-prefixed-messages count))
  22.       (dir default-directory)
  23.       (message-pointer vm-message-pointer)
  24.       (case-fold-search t)
  25.       to cc subject mp in-reply-to references tmp tmp2 newsgroups)
  26.       (setq mp mlist)
  27.       (while mp 
  28.     (cond
  29.      ((eq mlist mp)
  30.       (cond ((setq to
  31.                (let ((reply-to
  32.                   (vm-get-header-contents (car mp) "Reply-To:"
  33.                               ", ")))
  34.              (if (vm-ignored-reply-to reply-to)
  35.                  nil
  36.                reply-to ))))
  37.         ((setq to (vm-get-header-contents (car mp) "From:" ", ")))
  38.         ;; bad, but better than nothing for some
  39.         ((setq to (vm-grok-From_-author (car mp))))
  40.         (t (error "No From: or Reply-To: header in message")))
  41.       (setq subject (vm-get-header-contents (car mp) "Subject:")
  42.         in-reply-to
  43.         (and vm-in-reply-to-format
  44.              (let ((vm-summary-uninteresting-senders nil))
  45.                (vm-sprintf 'vm-in-reply-to-format (car mp))))
  46.         in-reply-to (and (not (equal "" in-reply-to)) in-reply-to))
  47.       (and subject vm-reply-subject-prefix
  48.            (let ((case-fold-search t))
  49.          (not
  50.           (equal
  51.            (string-match (regexp-quote vm-reply-subject-prefix)
  52.                  subject)
  53.            0)))
  54.            (setq subject (concat vm-reply-subject-prefix subject))))
  55.      (t (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:"
  56.                              ", "))
  57.            (setq to (concat to "," tmp)))
  58.           ((setq tmp (vm-get-header-contents (car mp) "From:"
  59.                              ", "))
  60.            (setq to (concat to "," tmp)))
  61.           ;; bad, but better than nothing for some
  62.           ((setq tmp (vm-grok-From_-author (car mp)))
  63.            (setq to (concat to "," tmp)))
  64.           (t (error "No From: or Reply-To: header in message")))))
  65.     (if to-all
  66.         (progn
  67.           (setq tmp (vm-get-header-contents (car mp) "To:"
  68.                         ", "))
  69.           (setq tmp2 (vm-get-header-contents (car mp) "Cc:"
  70.                          ", "))
  71.           (if tmp
  72.           (if cc
  73.               (setq cc (concat cc "," tmp))
  74.             (setq cc tmp)))
  75.           (if tmp2
  76.           (if cc
  77.               (setq cc (concat cc "," tmp2))
  78.             (setq cc tmp2)))))
  79.     (setq references
  80.           (cons (vm-get-header-contents (car mp) "References:" " ")
  81.             (cons (vm-get-header-contents (car mp) "In-reply-to:" " ")
  82.               (cons (vm-get-header-contents (car mp) "Message-ID:"
  83.                             " ")
  84.                 references))))
  85.     (setq newsgroups
  86.           (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To:" ","))
  87.             (vm-get-header-contents (car mp) "Newsgroups:" ","))
  88.             newsgroups))
  89.     (setq mp (cdr mp)))
  90.       (if vm-strip-reply-headers
  91.       (let ((mail-use-rfc822 t))
  92.         (and to (setq to (mail-strip-quoted-names to)))
  93.         (and cc (setq cc (mail-strip-quoted-names cc)))))
  94.       (setq to (vm-parse-addresses to)
  95.         cc (vm-parse-addresses cc))
  96.       (if vm-reply-ignored-addresses
  97.       (setq to (vm-strip-ignored-addresses to)
  98.         cc (vm-strip-ignored-addresses cc)))
  99.       (setq to (vm-delete-duplicates to nil t))
  100.       (setq cc (vm-delete-duplicates
  101.         (append (vm-delete-duplicates cc nil t)
  102.             to (copy-sequence to))
  103.         t t))
  104.       (and to (setq to (mapconcat 'identity to ",\n    ")))
  105.       (and cc (setq cc (mapconcat 'identity cc ",\n    ")))
  106.       (and (null to) (setq to cc cc nil))
  107.       (setq references (delq nil references)
  108.         references (mapconcat 'identity references " ")
  109.         references (vm-parse references "[^<]*\\(<[^>]+>\\)")
  110.         references (vm-delete-duplicates references)
  111.         references (if references (mapconcat 'identity references "\n\t")))
  112.       (setq newsgroups (delq nil newsgroups)
  113.         newsgroups (mapconcat 'identity newsgroups ",")
  114.         newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
  115.         newsgroups (vm-delete-duplicates newsgroups)
  116.         newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
  117.       (vm-mail-internal
  118.        (format "reply to %s%s" (vm-su-full-name (car mlist))
  119.            (if (cdr mlist) ", ..." ""))
  120.        to subject in-reply-to cc references newsgroups)
  121.       (make-local-variable 'vm-reply-list)
  122.       (setq vm-system-state 'replying
  123.         vm-reply-list mlist
  124.         default-directory dir)
  125.       (if include-text
  126.       (save-excursion
  127.         (goto-char (point-min))
  128.         (let ((case-fold-search nil))
  129.           (re-search-forward
  130.            (concat "^" (regexp-quote mail-header-separator) "$") nil 0))
  131.         (forward-char 1)
  132.         (while mlist
  133.           (save-restriction
  134.         (narrow-to-region (point) (point))
  135.         (vm-yank-message (car mlist))
  136.         (goto-char (point-max)))
  137.           (setq mlist (cdr mlist)))))
  138.       (run-hooks 'vm-reply-hook)
  139.       (run-hooks 'vm-mail-mode-hook)))
  140.  
  141. (defun vm-strip-ignored-addresses (addresses)
  142.   (setq addresses (copy-sequence addresses))
  143.   (let (re-list list addr-list)
  144.     (setq re-list vm-reply-ignored-addresses)
  145.     (while re-list
  146.       (setq addr-list addresses)
  147.       (while addr-list
  148.     (if (string-match (car re-list) (car addr-list))
  149.         (setq addresses (delq (car addr-list) addresses)))
  150.     (setq addr-list (cdr addr-list)))
  151.       (setq re-list (cdr re-list))))
  152.   addresses )
  153.  
  154. (defun vm-ignored-reply-to (reply-to)
  155.   (if reply-to
  156.       (let (re-list result)
  157.     (setq re-list vm-reply-ignored-reply-tos)
  158.     (while re-list
  159.       (if (string-match (car re-list) reply-to)
  160.           (setq result t re-list nil)
  161.         (setq re-list (cdr re-list))))
  162.     result )))
  163.  
  164. (defun vm-mail-yank-default (message)
  165.   (save-excursion
  166.     (vm-reorder-message-headers nil vm-included-text-headers
  167.                 vm-included-text-discard-header-regexp)
  168.     ;; if all the headers are gone, delete the trailing blank line, too.
  169.     (if (eq (following-char) ?\n)
  170.     (delete-char 1))
  171.     (if vm-included-text-attribution-format
  172.     (let ((vm-summary-uninteresting-senders nil))
  173.       (insert (vm-sprintf 'vm-included-text-attribution-format message))))
  174.     ; turn off zmacs-regions for Lucid Emacs 19
  175.     ; and get around transient-mark-mode in FSF Emacs 19
  176.     ; all this so that (mark) does what it did in v18, sheesh.
  177.     (let* ((zmacs-regions nil)
  178.        (mark-even-if-inactive t)
  179.        (end (mark-marker)))
  180.       (while (< (point) end)
  181.     (insert vm-included-text-prefix)
  182.     (forward-line 1)))))
  183.  
  184. (defun vm-yank-message-other-folder (folder)
  185.   "Like vm-yank-message except the message is yanked from a folder other
  186. than the one that spawned the current Mail mode buffer.  The name of the
  187. folder is read from the minibuffer.
  188.  
  189. Don't call this function from a program."
  190.   (interactive
  191.    (list
  192.     (let ((dir (if vm-folder-directory
  193.             (expand-file-name vm-folder-directory)
  194.           default-directory))
  195.       (last-command last-command)
  196.       (this-command this-command))
  197.       (read-file-name "Yank from folder: " dir nil t))))
  198.   (let ((b (current-buffer)) newbuf sumbuf default result prompt mp)
  199.     (set-buffer (or (vm-get-file-buffer folder) (find-file-noselect folder)))
  200.     (setq newbuf (current-buffer))
  201.     (if (not (eq major-mode 'vm-mode))
  202.     (vm-mode))
  203.     (if vm-presentation-buffer-handle
  204.     (vm-bury-buffer vm-presentation-buffer-handle))
  205.     (if (null vm-message-pointer)
  206.     (error "No messages in folder %s" folder))
  207.     (setq default (vm-number-of (car vm-message-pointer)))
  208.     (save-excursion
  209.       (save-window-excursion
  210.     (save-window-excursion
  211.       (vm-summarize))
  212.     (vm-display vm-summary-buffer t '(vm-yank-message-other-folder)
  213.             '(vm-yank-message-other-folder composing-message))
  214.     (setq sumbuf (current-buffer))
  215.     (setq prompt (format "Yank message number: (default %s) " default)
  216.           result 0)
  217.     (while (zerop result)
  218.       (setq result (read-string prompt))
  219.       (and (string= result "") default (setq result default))
  220.       (setq result (string-to-int result)))
  221.     (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  222.         (error "No such message."))))
  223.     (set-buffer b)
  224.     (unwind-protect
  225.     (let ((vm-mail-buffer newbuf))
  226.       (vm-yank-message (car mp)))
  227.       (vm-bury-buffer newbuf)
  228.       (vm-bury-buffer sumbuf))))
  229.  
  230. (defun vm-yank-message (message)
  231.   "Yank message number N into the current buffer at point.
  232. When called interactively N is always read from the minibuffer.  When
  233. called non-interactively the first argument is expected to be a
  234. message struct.
  235.  
  236. This command is meant to be used in VM created Mail mode buffers; the
  237. yanked message comes from the mail buffer containing the message you
  238. are replying to, forwarding, or invoked VM's mail command from.
  239.  
  240. All message headers are yanked along with the text.  Point is
  241. left before the inserted text, the mark after.  Any hook
  242. functions bound to mail-citation-hook are run, after inserting
  243. the text and setting point and mark.  For backward compatibility,
  244. if mail-citation-hook is set to nil, `mail-yank-hooks' is run
  245. instead.
  246.  
  247. If mail-citation-hook and mail-yank-hooks are both nil, this
  248. default action is taken: the yanked headers are trimmed as
  249. specified by vm-included-text-headers and
  250. vm-included-text-discard-header-regexp, and the value of
  251. vm-included-text-prefix is prepended to every yanked line."
  252.   (interactive
  253.    (list
  254.    ;; What we really want for the first argument is a message struct,
  255.    ;; but if called interactively, we let the user type in a message
  256.    ;; number instead.
  257.     (let (mp default
  258.       (result 0)
  259.       prompt
  260.       (last-command last-command)
  261.       (this-command this-command))
  262.       (save-excursion
  263.     (vm-select-folder-buffer)
  264.     (setq default (and vm-message-pointer
  265.                (vm-number-of (car vm-message-pointer)))
  266.           prompt (if default
  267.              (format "Yank message number: (default %s) "
  268.                  default)
  269.                "Yank message number: "))
  270.     (while (zerop result)
  271.       (setq result (read-string prompt))
  272.       (and (string= result "") default (setq result default))
  273.       (setq result (string-to-int result)))
  274.     (if (null (setq mp (nthcdr (1- result) vm-message-list)))
  275.         (error "No such message.")))
  276.       (car mp))))
  277.   (if (not (bufferp vm-mail-buffer))
  278.       (error "This is not a VM Mail mode buffer."))
  279.   (if (null (buffer-name vm-mail-buffer))
  280.       (error "The folder buffer containing message %d has been killed."
  281.          (vm-number-of message)))
  282.   (vm-display nil nil '(vm-yank-message) '(vm-yank-message composing-message))
  283.   (setq message (vm-real-message-of message))
  284.   (let ((b (current-buffer)) (start (point)) end)
  285.     (save-restriction
  286.       (widen)
  287.       (save-excursion
  288.     (if (vectorp (vm-mm-layout message))
  289.         (let* ((o (vm-mm-layout message))
  290.            (type (car (vm-mm-layout-type o)))
  291.            parts)
  292.           (vm-insert-region-from-buffer (vm-buffer-of message)
  293.                         (vm-headers-of message)
  294.                         (vm-text-of message))
  295.           (cond ((vm-mime-types-match "multipart" type)
  296.              (setq parts (copy-sequence (vm-mm-layout-parts o))))
  297.             (t (setq parts (list o))))
  298.           (while parts
  299.         (cond ((vm-mime-text-type-layout-p (car parts))
  300.                (if (cond ((vm-mime-types-match
  301.                    "text/enriched"
  302.                    (car (vm-mm-layout-type (car parts))))
  303.                   (vm-mime-display-internal-text/enriched
  304.                    (car parts)))
  305. ;; no text/html for now
  306. ;;                 ((vm-mime-types-match
  307. ;;                   "text/html"
  308. ;;                   (car (vm-mm-layout-type (car parts))))
  309. ;;                  (vm-mime-display-internal-text/html
  310. ;;                   (car parts)))
  311.                  ((vm-mime-display-internal-text/plain
  312.                    (car parts) t)))
  313.                nil
  314.              ;; charset problems probably
  315.              ;; just dump the raw bits
  316.              (vm-mime-insert-mime-body (car parts))
  317.              (vm-mime-transfer-decode-region (car parts)
  318.                              start (point)))
  319.                (setq parts (cdr parts)))
  320.               ((vm-mime-composite-type-p
  321.             (car (vm-mm-layout-type (car parts))))
  322.                (setq parts (nconc (copy-sequence
  323.                        (vm-mm-layout-parts
  324.                         (car parts)))
  325.                       (cdr parts))))
  326.               (t (setq parts (cdr parts)))))
  327.           (setq end (point-marker)))
  328.       (set-buffer (vm-buffer-of message))
  329.       (save-restriction
  330.         (widen)
  331.         (append-to-buffer b (vm-headers-of message)
  332.                   (vm-text-end-of message))
  333.         (setq end (vm-marker (+ start (- (vm-text-end-of message)
  334.                          (vm-headers-of message))) b)))))
  335.       ;; get rid of read-only text properties on the text, as
  336.       ;; they will only cause trouble.
  337.       (let ((inhibit-read-only t))
  338.     (remove-text-properties (point-min) (point-max) '(read-only nil)
  339.                 (current-buffer)))
  340.       (push-mark end)
  341.       (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
  342.         (mail-yank-hooks (run-hooks 'mail-yank-hooks))
  343.         (t (vm-mail-yank-default message))))))
  344.  
  345. (defun vm-mail-send-and-exit (arg)
  346.   "Just like mail-send-and-exit except that VM flags the appropriate message(s)
  347. as having been replied to, if appropriate."
  348.   (interactive "P")
  349.   (vm-check-for-killed-folder)
  350.   (let ((b (current-buffer)))
  351.     (vm-mail-send)
  352.     (cond ((null (buffer-name b)) ;; dead buffer
  353.        ;; This improves window configuration behavior in
  354.        ;; XEmacs.  It avoids taking the folder buffer from
  355.        ;; one frame and attaching it to the selected frame.
  356.        (set-buffer (window-buffer (selected-window)))
  357.        (vm-display nil nil '(vm-mail-send-and-exit)
  358.                '(vm-mail-send-and-exit
  359.              reading-message
  360.              startup)))
  361.       (t
  362.        (vm-display b nil '(vm-mail-send-and-exit)
  363.                '(vm-mail-send-and-exit reading-message startup))
  364.        (vm-bury-buffer b)))))
  365.  
  366. (defun vm-keep-mail-buffer (buffer)
  367.   ;; keep this buffer if the user demands it
  368.   (if (memq buffer vm-kept-mail-buffers)
  369.       (setq vm-kept-mail-buffers
  370.         (delq buffer vm-kept-mail-buffers)))
  371.   (setq vm-kept-mail-buffers (cons buffer vm-kept-mail-buffers)
  372.     vm-kept-mail-buffers (vm-delete 'buffer-name
  373.                     vm-kept-mail-buffers t))
  374.   (if (not (eq vm-keep-sent-messages t))
  375.       (let ((extras (nthcdr (or vm-keep-sent-messages 0)
  376.                 vm-kept-mail-buffers)))
  377.     (mapcar (function
  378.          (lambda (b)
  379.            (and (buffer-name b)
  380.             (not (buffer-modified-p b))
  381.             (kill-buffer b))))
  382.         extras)
  383.     (and vm-kept-mail-buffers extras
  384.          (setcdr (memq (car extras) vm-kept-mail-buffers) nil)))))
  385.  
  386. (defun vm-help-tale ()
  387.   (save-excursion
  388.     (goto-char (point-min))
  389.     (while (vm-match-header)
  390.       (if (not (vm-match-header "To:\\|Resent-To:\\|Cc:\\|Resent-Cc:"))
  391.       (goto-char (vm-matched-header-end))
  392.     (goto-char (vm-matched-header-contents-start))
  393.     (if (re-search-forward "[^, \t][ \t]*\n[ \t\n]+[^ \t\n]"
  394.                    (vm-matched-header-contents-end)
  395.                    t)
  396.         (error "tale is an idiot, and so are you. :-)"))
  397.     (goto-char (vm-matched-header-end))))))
  398.  
  399. (defun vm-mail-send ()
  400.   "Just like mail-send except that VM flags the appropriate message(s)
  401. as replied to, forwarded, etc, if appropriate."
  402.   (interactive)
  403.   (if vm-tale-is-an-idiot
  404.       (vm-help-tale))
  405.   ;; protect value of this-command from minibuffer read
  406.   (let ((this-command this-command))
  407.     (if (and vm-confirm-mail-send
  408.          (not (y-or-n-p "Send the message? ")))
  409.     (error "Message not sent.")))
  410.   ;; insert a Date header if it's not already present.
  411.   (if (null (vm-mail-mode-get-header-contents "Date:"))
  412.       (save-restriction
  413.     (save-excursion
  414.       (let* ((timezone (car (current-time-zone)))
  415.          (hour (/ timezone 3600))
  416.          (min (/ (- timezone (* hour 3600)) 60)))
  417.         (widen)
  418.         (goto-char (point-min))
  419.         (insert (format-time-string "Date: %a, %e %b %Y %H:%M:%S")
  420.             (format " %s%02d%02d"
  421.                 (if (< timezone 0) "-" "+")
  422.                 (abs hour)
  423.                 (abs min))
  424.             (format-time-string " (%Z)")
  425.             "\n")))))
  426.   ;; send mail using MIME if user requests it and if the buffer
  427.   ;; has not already been MIME encoded.
  428.   (if (and vm-send-using-mime
  429.        (null (vm-mail-mode-get-header-contents "MIME-Version:")))
  430.       (vm-mime-encode-composition))
  431.   ;; this to prevent Emacs 19 from asking whether a message that
  432.   ;; has already been sent should be sent again.  VM renames mail
  433.   ;; buffers after the message has been sent, so the user should
  434.   ;; already know that the message has been sent.
  435.   (set-buffer-modified-p t)
  436.   (let ((composition-buffer (current-buffer))
  437.     ;; preserve these in case the composition buffer gets
  438.     ;; killed.
  439.     (vm-reply-list vm-reply-list)
  440.     (vm-forward-list vm-forward-list)
  441.     (vm-redistribute-list vm-redistribute-list))
  442.     ;; fragment message using message/partial if it is too big.
  443.     (if (and vm-send-using-mime
  444.          (integerp vm-mime-max-message-size)
  445.          (> (buffer-size) vm-mime-max-message-size))
  446.     (let (list)
  447.       (setq list (vm-mime-fragment-composition vm-mime-max-message-size))
  448.       (while list
  449.         (save-excursion
  450.           (set-buffer (car list))
  451.           (vm-mail-send)
  452.           (kill-buffer (car list)))
  453.         (setq list (cdr list)))
  454.       ;; what mail-send would have done
  455.       (set-buffer-modified-p nil))
  456.       ;; don't want a buffer change to occur here
  457.       ;; save-excursion to be sure.
  458.       ;;
  459.       ;; also protect value of this-command from minibuffer reads
  460.       (let ((this-command this-command))
  461.     (save-excursion
  462.       (mail-send))))
  463.     ;; be careful, something could have killed the composition
  464.     ;; buffer inside mail-send.
  465.     (if (eq (current-buffer) composition-buffer)
  466.     (progn
  467.       (cond ((eq vm-system-state 'replying)
  468.          (vm-mail-mark-replied))
  469.         ((eq vm-system-state 'forwarding)
  470.          (vm-mail-mark-forwarded))
  471.         ((eq vm-system-state 'redistributing)
  472.          (vm-mail-mark-redistributed)))
  473.       (vm-rename-current-mail-buffer)
  474.       (vm-keep-mail-buffer (current-buffer))))
  475.     (vm-display nil nil '(vm-mail-send) '(vm-mail-send))))
  476.  
  477. (defun vm-mail-mode-get-header-contents (header-name-regexp)
  478.   (let ((contents nil)
  479.     regexp)
  480.     (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^"
  481.              (regexp-quote mail-header-separator) "$\\)"))
  482.     (save-excursion
  483.       (save-restriction
  484.     (widen)
  485.     (goto-char (point-min))
  486.     (let ((case-fold-search t))
  487.       (if (and (re-search-forward regexp nil t)
  488.            (match-beginning 1)
  489.            (progn (goto-char (match-beginning 0))
  490.               (vm-match-header)))
  491.           (vm-matched-header-contents)
  492.         nil ))))))
  493.  
  494. (defun vm-rename-current-mail-buffer ()
  495.   (if vm-rename-current-buffer-function
  496.       (funcall vm-rename-current-buffer-function)
  497.     (let ((case-fold-search nil))
  498.       (if (not (string-match "^sent " (buffer-name)))
  499.       (let (prefix name n)
  500.         (if (not (= ?* (aref (buffer-name) 0)))
  501.         (setq prefix (format "sent %s" (buffer-name)))
  502.           (let (recipients)
  503.         (cond ((not (zerop (length (setq recipients
  504.                          (mail-fetch-field "To"))))))
  505.               ((not (zerop (length (setq recipients
  506.                          (mail-fetch-field "Cc"))))))
  507.               ((not (zerop (length (setq recipients
  508.                          (mail-fetch-field "Bcc"))))))
  509.                     ; can't happen?!?
  510.               (t (setq recipients "the horse with no name")))
  511.         (setq prefix (format "sent mail to %s" recipients))))
  512.         (if (> (length prefix) 44)
  513.         (setq prefix (concat (substring prefix 0 40) " ...")))
  514.         (setq name prefix n 2)
  515.         (while (get-buffer name)
  516.           (setq name (format "%s<%d>" prefix n))
  517.           (vm-increment n))
  518.         (rename-buffer name))))))
  519.  
  520. (defun vm-mail-mark-replied ()
  521.   (save-excursion
  522.     (let ((mp vm-reply-list))
  523.       (while mp
  524.     (if (null (buffer-name (vm-buffer-of (car mp))))
  525.         ()
  526.       (set-buffer (vm-buffer-of (car mp)))
  527.       (cond ((and (memq (car mp) vm-message-list)
  528.               (null (vm-replied-flag (car mp))))
  529.          (vm-set-replied-flag (car mp) t))))
  530.     (setq mp (cdr mp)))
  531.       (vm-update-summary-and-mode-line))))
  532.  
  533. (defun vm-mail-mark-forwarded ()
  534.   (save-excursion
  535.     (let ((mp vm-forward-list))
  536.       (while mp
  537.     (if (null (buffer-name (vm-buffer-of (car mp))))
  538.         ()
  539.       (set-buffer (vm-buffer-of (car mp)))
  540.       (cond ((and (memq (car mp) vm-message-list)
  541.               (null (vm-forwarded-flag (car mp))))
  542.          (vm-set-forwarded-flag (car mp) t))))
  543.     (setq mp (cdr mp)))
  544.       (vm-update-summary-and-mode-line))))
  545.  
  546. (defun vm-mail-mark-redistributed ()
  547.   (save-excursion
  548.     (let ((mp vm-redistribute-list))
  549.       (while mp
  550.     (if (null (buffer-name (vm-buffer-of (car mp))))
  551.         ()
  552.       (set-buffer (vm-buffer-of (car mp)))
  553.       (cond ((and (memq (car mp) vm-message-list)
  554.               (null (vm-redistributed-flag (car mp))))
  555.          (vm-set-redistributed-flag (car mp) t))))
  556.     (setq mp (cdr mp)))
  557.       (vm-update-summary-and-mode-line))))
  558.  
  559. (defun vm-reply (count)
  560.   "Reply to the sender of the current message.
  561. Numeric prefix argument N means to reply to the current message plus the
  562. next N-1 messages.  A negative N means reply to the current message and
  563. the previous N-1 messages. 
  564.  
  565. If invoked on marked messages (via vm-next-command-uses-marks),
  566. all marked messages will be replied to.
  567.  
  568. You will be placed into a standard Emacs Mail mode buffer to compose and
  569. send your message.  See the documentation for the function `mail' for
  570. more info.
  571.  
  572. Note that the normal binding of C-c C-y in the reply buffer is
  573. automatically changed to vm-yank-message during a reply.  This
  574. allows you to yank any message from the current folder into a
  575. reply.
  576.  
  577. Normal VM commands may be accessed in the reply buffer by prefixing them
  578. with C-c C-v."
  579.   (interactive "p")
  580.   (vm-follow-summary-cursor)
  581.   (vm-select-folder-buffer)
  582.   (vm-check-for-killed-summary)
  583.   (vm-error-if-folder-empty)
  584.   (vm-do-reply nil nil count))
  585.  
  586. (defun vm-reply-include-text (count)
  587.   "Reply to the sender (only) of the current message and include text
  588. from the message.  See the documentation for function vm-reply for details."
  589.   (interactive "p")
  590.   (vm-follow-summary-cursor)
  591.   (vm-select-folder-buffer)
  592.   (vm-check-for-killed-summary)
  593.   (vm-error-if-folder-empty)
  594.   (vm-do-reply nil t count))
  595.  
  596. (defun vm-followup (count)
  597.   "Reply to all recipients of the current message.
  598. See the documentation for the function vm-reply for details."
  599.   (interactive "p")
  600.   (vm-follow-summary-cursor)
  601.   (vm-select-folder-buffer)
  602.   (vm-check-for-killed-summary)
  603.   (vm-error-if-folder-empty)
  604.   (vm-do-reply t nil count))
  605.  
  606. (defun vm-followup-include-text (count)
  607.   "Reply to all recipients of the current message and include text from
  608. the message.  See the documentation for the function vm-reply for details."
  609.   (interactive "p")
  610.   (vm-follow-summary-cursor)
  611.   (vm-select-folder-buffer)
  612.   (vm-check-for-killed-summary)
  613.   (vm-error-if-folder-empty)
  614.   (vm-do-reply t t count))
  615.  
  616. (defun vm-forward-message-all-headers ()
  617.   "Like vm-forward-message but always forwards all the headers."
  618.   (interactive)
  619.   (let ((vm-forwarded-headers nil)
  620.     (vm-unforwarded-header-regexp "only-drop-this-header")
  621.     ;; set these because vm-forward-message calls vm-send-digest
  622.     ;; if there is more than one message to be forwarded.
  623.     (vm-rfc934-digest-headers nil)
  624.     (vm-rfc934-digest-discard-header-regexp "only-drop-this-header")
  625.     (vm-rfc1153-digest-headers nil)
  626.     (vm-rfc1153-digest-discard-header-regexp "only-drop-this-header")
  627.     (vm-mime-digest-headers nil)
  628.     (vm-mime-digest-discard-header-regexp "only-drop-this-header"))
  629.     (vm-forward-message)))
  630.  
  631. (defun vm-forward-message ()
  632.   "Forward the current message to one or more recipients.
  633. You will be placed in a Mail mode buffer as you would with a
  634. reply, but you must fill in the To: header and perhaps the
  635. Subject: header manually."
  636.   (interactive)
  637.   (vm-follow-summary-cursor)
  638.   (vm-select-folder-buffer)
  639.   (vm-check-for-killed-summary)
  640.   (vm-error-if-folder-empty)
  641.   (if (and (eq last-command 'vm-next-command-uses-marks)
  642.        (cdr (vm-select-marked-or-prefixed-messages 0)))
  643.       (let ((vm-digest-send-type vm-forwarding-digest-type))
  644.     (setq this-command 'vm-next-command-uses-marks)
  645.     (command-execute 'vm-send-digest))
  646.     (let ((dir default-directory)
  647.       (miming (and vm-send-using-mime
  648.                (equal vm-forwarding-digest-type "mime")))
  649.       mail-buffer
  650.       header-end
  651.       (mp (vm-select-marked-or-prefixed-messages 1)))
  652.       (save-restriction
  653.     (widen)
  654.     (vm-mail-internal
  655.      (format "forward of %s's note re: %s"
  656.          (vm-su-full-name (car vm-message-pointer))
  657.          (vm-su-subject (car vm-message-pointer)))
  658.      nil
  659.      (and vm-forwarding-subject-format
  660.           (let ((vm-summary-uninteresting-senders nil))
  661.         (vm-sprintf 'vm-forwarding-subject-format (car mp)))))
  662.     (make-local-variable 'vm-forward-list)
  663.     (setq vm-system-state 'forwarding
  664.           vm-forward-list (list (car mp))
  665.           default-directory dir)
  666.     (if miming
  667.         (progn
  668.           (setq mail-buffer (current-buffer))
  669.           (set-buffer (generate-new-buffer "*vm-forward-buffer*"))
  670.           (setq header-end (point))
  671.           (insert "\n"))
  672.       (goto-char (point-min))
  673.       (re-search-forward (concat "^" (regexp-quote mail-header-separator)
  674.                      "\n"))
  675.       (goto-char (match-end 0))
  676.       (setq header-end (match-beginning 0)))
  677.     (cond ((equal vm-forwarding-digest-type "mime")
  678.            (vm-mime-encapsulate-messages (list (car mp))
  679.                          vm-forwarded-headers
  680.                          vm-unforwarded-header-regexp
  681.                          nil)
  682.            (goto-char header-end)
  683.            (insert "MIME-Version: 1.0\n")
  684.            (insert "Content-Type: message/rfc822\n")
  685.            (insert "Content-Transfer-Encoding: "
  686.                (vm-determine-proper-content-transfer-encoding
  687.             (point)
  688.             (point-max))
  689.                "\n"))
  690.           ((equal vm-forwarding-digest-type "rfc934")
  691.            (vm-rfc934-encapsulate-messages
  692.         vm-forward-list vm-forwarded-headers
  693.         vm-unforwarded-header-regexp))
  694.           ((equal vm-forwarding-digest-type "rfc1153")
  695.            (vm-rfc1153-encapsulate-messages
  696.         vm-forward-list vm-forwarded-headers
  697.         vm-unforwarded-header-regexp))
  698.           ((equal vm-forwarding-digest-type nil)
  699.            (vm-no-frills-encapsulate-message
  700.         (car vm-forward-list) vm-forwarded-headers
  701.         vm-unforwarded-header-regexp)))
  702.       (if miming
  703.       (let ((b (current-buffer)))
  704.         (set-buffer mail-buffer)
  705.         (mail-text)
  706.         (vm-mime-attach-object b "message/rfc822" nil nil t)
  707.         (add-hook 'kill-buffer-hook
  708.               (list 'lambda ()
  709.                 (list 'if (list 'eq mail-buffer '(current-buffer))
  710.                   (list 'kill-buffer b))))))
  711.     (mail-position-on-field "To"))
  712.       (run-hooks 'vm-forward-message-hook)
  713.       (run-hooks 'vm-mail-mode-hook))))
  714.  
  715. (defun vm-resend-bounced-message ()
  716.   "Extract the original text from a bounced message and resend it.
  717. You will be placed in a Mail mode buffer with the extracted message and
  718. you can change the recipient address before resending the message."
  719.   (interactive)
  720.   (vm-follow-summary-cursor)
  721.   (vm-select-folder-buffer)
  722.   (vm-check-for-killed-summary)
  723.   (vm-error-if-folder-empty)
  724.   (let ((b (current-buffer)) start
  725.     (dir default-directory)
  726.     (layout (vm-mm-layout (car vm-message-pointer)))
  727.     (lim (vm-text-end-of (car vm-message-pointer))))
  728.       (save-restriction
  729.     (widen)
  730.     (if (or (not (vectorp layout))
  731.         (not (setq layout (vm-mime-layout-contains-type
  732.                    layout "message/rfc822"))))
  733.         (save-excursion
  734.           (goto-char (vm-text-of (car vm-message-pointer)))
  735.           (let ((case-fold-search t))
  736.         ;; What a wonderful world it would be if mailers
  737.         ;; used a single message encapsulation standard
  738.         ;; instead of all the weird variants. It is
  739.         ;; useless to try to cover them all.  This simple
  740.         ;; rule should cover the sanest of the formats
  741.         (if (not (re-search-forward "^Received:" lim t))
  742.             (error "This doesn't look like a bounced message."))
  743.         (beginning-of-line)
  744.         (setq start (point)))))
  745.     ;; briefly nullify vm-mail-header-from to keep vm-mail-internal
  746.     ;; from inserting another From header.
  747.     (let ((vm-mail-header-from nil))
  748.       (vm-mail-internal
  749.        (format "retry of bounce from %s"
  750.            (vm-su-from (car vm-message-pointer)))))
  751.     (goto-char (point-min))
  752.     (if (vectorp layout)
  753.         (progn
  754.           (setq start (point))
  755.           (vm-mime-insert-mime-body layout)
  756.           (vm-mime-transfer-decode-region layout start (point)))
  757.       (insert-buffer-substring b start lim))
  758.     (delete-region (point) (point-max))
  759.     (goto-char (point-min))
  760.     ;; delete all but pertinent headers
  761.     (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)")
  762.     (vm-reorder-message-headers nil vm-resend-bounced-headers
  763.                     vm-resend-bounced-discard-header-regexp)
  764.     (if (search-forward "\n\n" nil t)
  765.         (replace-match "")
  766.       (goto-char (point-max)))
  767.     (insert ?\n mail-header-separator ?\n)
  768.     (goto-char (point-min))
  769.     (if vm-mail-header-from
  770.         (insert "Resent-From: " vm-mail-header-from ?\n))
  771.     (mail-position-on-field "Resent-To")
  772.     (setq default-directory dir)))
  773.   (run-hooks 'vm-resend-bounced-message-hook)
  774.   (run-hooks 'vm-mail-mode-hook))
  775.  
  776. (defun vm-resend-message ()
  777.   "Resend the current message to someone else.
  778. The current message will be copied to a Mail mode buffer and you
  779. can edit the message and send it as usual.
  780.  
  781. NOTE: since you are doing a resend, a Resent-To header is provided
  782. for you to fill in the new recipient list.  If you don't fill in
  783. this header, what happens when you send the message is undefined.
  784. You may also create a Resent-Cc header."
  785.   (interactive)
  786.   (vm-follow-summary-cursor)
  787.   (vm-select-folder-buffer)
  788.   (vm-check-for-killed-summary)
  789.   (vm-error-if-folder-empty)
  790.   (save-restriction
  791.     (widen)
  792.     (let ((b (current-buffer))
  793.       (dir default-directory)
  794.       (vmp vm-message-pointer)
  795.       (start (vm-headers-of (car vm-message-pointer)))
  796.       (lim (vm-text-end-of (car vm-message-pointer))))
  797.       ;; briefly nullify vm-mail-header-from to keep vm-mail-internal
  798.       ;; from inserting another From header.
  799.       (let ((vm-mail-header-from nil))
  800.     (vm-mail-internal
  801.      (format "resend of %s's note re: %s"
  802.          (vm-su-full-name (car vm-message-pointer))
  803.          (vm-su-subject (car vm-message-pointer)))))
  804.       (goto-char (point-min))
  805.       (insert-buffer-substring b start lim)
  806.       (delete-region (point) (point-max))
  807.       (goto-char (point-min))
  808.       (if vm-mail-header-from
  809.       (insert "Resent-From: " vm-mail-header-from ?\n))
  810.       (insert "Resent-To: \n")
  811.       (if mail-self-blind
  812.       (insert "Bcc: " (user-login-name) ?\n))
  813.       (if mail-archive-file-name
  814.       (insert "FCC: " mail-archive-file-name ?\n))
  815.       ;; delete all but pertinent headers
  816.       (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\|Sender:\\)")
  817.       (vm-reorder-message-headers nil vm-resend-headers
  818.                   vm-resend-discard-header-regexp)
  819.       (if (search-forward "\n\n" nil t)
  820.       (replace-match ""))
  821.       (insert ?\n mail-header-separator ?\n)
  822.       (goto-char (point-min))
  823.       (mail-position-on-field "Resent-To")
  824.       (make-local-variable 'vm-redistribute-list)
  825.       (setq vm-system-state 'redistributing
  826.         vm-redistribute-list (list (car vmp))
  827.         default-directory dir)
  828.       (run-hooks 'vm-resend-message-hook)
  829.       (run-hooks 'vm-mail-mode-hook))))
  830.  
  831. (defun vm-send-digest (&optional prefix)
  832.   "Send a digest of all messages in the current folder to recipients.
  833. The type of the digest is specified by the variable vm-digest-send-type.
  834. You will be placed in a Mail mode buffer as is usual with replies, but you
  835. must fill in the To: and Subject: headers manually.
  836.  
  837. Prefix arg means to insert a list of preamble lines at the beginning of
  838. the digest.  One line is generated for each message being digestified.
  839. The variable vm-digest-preamble-format determines the format of the
  840. preamble lines.
  841.  
  842. If invoked on marked messages (via vm-next-command-uses-marks),
  843. only marked messages will be put into the digest."
  844.   (interactive "P")
  845.   (vm-select-folder-buffer)
  846.   (vm-check-for-killed-summary)
  847.   (vm-error-if-folder-empty)
  848.   (let ((dir default-directory)
  849.     (miming (and vm-send-using-mime (equal vm-digest-send-type "mime")))
  850.     mp mail-buffer b
  851.     ;; prefix arg doesn't have "normal" meaning here, so only call
  852.     ;; vm-select-marked-or-prefixed-messages if we're using marks.
  853.     (mlist (if (eq last-command 'vm-next-command-uses-marks)
  854.            (vm-select-marked-or-prefixed-messages 0)
  855.          vm-message-list))
  856.     start header-end boundary)
  857.     (save-restriction
  858.       (widen)
  859.       (vm-mail-internal (format "digest from %s" (buffer-name)))
  860.       (make-local-variable 'vm-forward-list)
  861.       (setq vm-system-state 'forwarding
  862.         vm-forward-list mlist
  863.         default-directory dir)
  864.       (if miming
  865.       (progn
  866.         (setq mail-buffer (current-buffer))
  867.         (set-buffer (generate-new-buffer "*vm-digest-buffer*"))
  868.         (setq header-end (point))
  869.         (insert "\n")
  870.         (setq start (point-marker)))
  871.     (goto-char (point-min))
  872.     (re-search-forward (concat "^" (regexp-quote mail-header-separator)
  873.                    "\n"))
  874.     (goto-char (match-end 0))
  875.     (setq start (point-marker)
  876.           header-end (match-beginning 0)))
  877.       (message "Building %s digest..." vm-digest-send-type)
  878.       (cond ((equal vm-digest-send-type "mime")
  879.          (setq boundary (vm-mime-encapsulate-messages
  880.                  mlist vm-mime-digest-headers
  881.                  vm-mime-digest-discard-header-regexp
  882.                  t))
  883.          (goto-char header-end)
  884.          (insert "MIME-Version: 1.0\n")
  885.          (insert (if vm-mime-avoid-folding-content-type
  886.              "Content-Type: multipart/digest; boundary=\""
  887.                "Content-Type: multipart/digest;\n\tboundary=\"")
  888.              boundary "\"\n")
  889.          (insert "Content-Transfer-Encoding: "
  890.              (vm-determine-proper-content-transfer-encoding
  891.               (point)
  892.               (point-max))
  893.              "\n"))
  894.         ((equal vm-digest-send-type "rfc934")
  895.          (vm-rfc934-encapsulate-messages
  896.           mlist vm-rfc934-digest-headers
  897.           vm-rfc934-digest-discard-header-regexp))
  898.         ((equal vm-digest-send-type "rfc1153")
  899.          (vm-rfc1153-encapsulate-messages
  900.           mlist vm-rfc1153-digest-headers
  901.           vm-rfc1153-digest-discard-header-regexp)))
  902.       (goto-char start)
  903.       (setq mp mlist)
  904.       (if miming
  905.       (let ((b (current-buffer)))
  906.         (set-buffer mail-buffer)
  907.         (mail-text)
  908.         (vm-mime-attach-object b "multipart/digest"
  909.                    (list (concat "boundary=\""
  910.                          boundary "\"")) nil t)
  911.         (add-hook 'kill-buffer-hook
  912.               (list 'lambda ()
  913.                 (list 'if (list 'eq mail-buffer '(current-buffer))
  914.                   (list 'kill-buffer b))))))
  915.       (if prefix
  916.       (save-excursion
  917.         (message "Building digest preamble...")
  918.         (if miming
  919.         (progn
  920.           (set-buffer mail-buffer)
  921.           (mail-text)))
  922.         (while mp
  923.           (let ((vm-summary-uninteresting-senders nil))
  924.         (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n"))
  925.           (if vm-digest-center-preamble
  926.           (progn
  927.             (forward-char -1)
  928.             (center-line)
  929.             (forward-char 1)))
  930.           (setq mp (cdr mp)))))
  931.       (mail-position-on-field "To")
  932.       (message "Building %s digest... done" vm-digest-send-type)))
  933.   (run-hooks 'vm-send-digest-hook)
  934.   (run-hooks 'vm-mail-mode-hook))
  935.  
  936. (defun vm-send-rfc934-digest (&optional preamble)
  937.   "Like vm-send-digest but always sends an RFC 934 digest."
  938.   (interactive "P")
  939.   (let ((vm-digest-send-type "rfc934"))
  940.     (vm-send-digest preamble)))
  941.  
  942. (defun vm-send-rfc1153-digest (&optional preamble)
  943.   "Like vm-send-digest but always sends an RFC 1153 digest."
  944.   (interactive "P")
  945.   (let ((vm-digest-send-type "rfc1153"))
  946.     (vm-send-digest preamble)))
  947.  
  948. (defun vm-send-mime-digest (&optional preamble)
  949.   "Like vm-send-digest but always sends an MIME (multipart/digest) digest."
  950.   (interactive "P")
  951.   (let ((vm-digest-send-type "mime"))
  952.     (vm-send-digest preamble)))
  953.  
  954. (defun vm-continue-composing-message (&optional not-picky)
  955.   "Find and select the most recently used mail composition buffer.
  956. If the selected buffer is already a Mail mode buffer then it is
  957. buried before beginning the search.  Non Mail mode buffers and
  958. unmodified Mail buffers are skipped.  Prefix arg means unmodified
  959. Mail mode buffers are not skipped.  If no suitable buffer is
  960. found, the current buffer remains selected."
  961.   (interactive "P")
  962.   (if (eq major-mode 'mail-mode)
  963.       (vm-bury-buffer (current-buffer)))
  964.   (let ((b (vm-find-composition-buffer not-picky)))
  965.     (if (not (or (null b) (eq b (current-buffer))))
  966.     (progn
  967.       ;; avoid having the window configuration code choose a
  968.       ;; different composition buffer.
  969.       (vm-unbury-buffer b)
  970.       (set-buffer b)
  971.       (if (and vm-mutable-frames vm-frame-per-composition
  972.            (vm-multiple-frames-possible-p)
  973.            ;; only pop up a frame if there's an undisplay
  974.            ;; hook in place to make the frame go away.
  975.            vm-undisplay-buffer-hook)
  976.           (let ((w (vm-get-buffer-window b)))
  977.         (if (null w)
  978.             (vm-goto-new-frame 'composition)
  979.           (select-window w)
  980.           (and vm-warp-mouse-to-new-frame
  981.                (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))
  982.         ;; need to do this here too, since XEmacs has per
  983.         ;; frame buffer lists.
  984.         (vm-unbury-buffer b)
  985.         (vm-set-hooks-for-frame-deletion)))
  986.       (vm-display b t '(vm-continue-composing-message)
  987.               '(vm-continue-composing-message composing-message)))
  988.       (message "No composition buffers found"))))
  989.  
  990. (defun vm-mail-to-mailto-url (url)
  991.   (let ((address (car (vm-parse url "^mailto:\\(.+\\)"))))
  992.     (vm-select-folder-buffer)
  993.     (vm-check-for-killed-summary)
  994.     (vm-mail-internal nil address)
  995.     (run-hooks 'vm-mail-hook)
  996.     (run-hooks 'vm-mail-mode-hook)))
  997.  
  998. ;; to quiet the v19 byte compiler
  999. (defvar mail-mode-map)
  1000. (defvar mail-aliases)
  1001. (defvar mail-default-reply-to)
  1002. (defvar mail-signature-file)
  1003.  
  1004. (defun vm-mail-internal
  1005.     (&optional buffer-name to subject in-reply-to cc references newsgroups)
  1006.   (let ((folder-buffer nil))
  1007.     (if (memq major-mode '(vm-mode vm-virtual-mode))
  1008.     (setq folder-buffer (current-buffer)))
  1009.     (set-buffer (generate-new-buffer (or buffer-name "*VM-mail*")))
  1010.     ;; avoid trying to write auto-save files in potentially
  1011.     ;; unwritable directories.
  1012.     (setq default-directory (or vm-folder-directory (expand-file-name "~/")))
  1013.     (auto-save-mode (if auto-save-default 1 -1))
  1014.     (mail-mode)
  1015.     (use-local-map vm-mail-mode-map)
  1016.     ;; make mail-mode-map the parent of this vm-mail-mode-map, if we can.
  1017.     ;; do it only once.
  1018.     (if (not vm-mail-mode-map-parented)
  1019.     (cond ((fboundp 'set-keymap-parents)
  1020.            (set-keymap-parents vm-mail-mode-map (list mail-mode-map))
  1021.            (setq vm-mail-mode-map-parented t))
  1022.           ((consp mail-mode-map)
  1023.            (nconc vm-mail-mode-map mail-mode-map)
  1024.            (setq vm-mail-mode-map-parented t))))
  1025.     (setq vm-mail-buffer folder-buffer
  1026.       mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
  1027.                    (vm-menu-support-possible-p)
  1028.                    (vm-menu-mode-menu)))
  1029.     (and vm-use-menus (vm-menu-support-possible-p)
  1030.      (vm-menu-install-mail-mode-menu))
  1031.     (if (fboundp 'mail-aliases-setup) ; use mail-abbrevs.el if present
  1032.     (mail-aliases-setup)
  1033.       (if (eq mail-aliases t)
  1034.       (progn
  1035.         (setq mail-aliases nil)
  1036.         (if (file-exists-p (or mail-personal-alias-file "~/.mailrc"))
  1037.         (build-mail-aliases)))))
  1038.     (if (stringp vm-mail-header-from)
  1039.     (insert "From: " vm-mail-header-from "\n"))
  1040.     (insert "To: " (or to "") "\n")
  1041.     (and cc (insert "Cc: " cc "\n"))
  1042.     (insert "Subject: " (or subject "") "\n")
  1043.     (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
  1044.     (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
  1045.     (and references (insert "References: " references "\n"))
  1046.     (insert "X-Mailer: VM " vm-version " under "
  1047.         (if vm-fsfemacs-p "Emacs " "")
  1048.         emacs-version "\n")
  1049.     (let ((time (current-time)))
  1050.       (insert (format "Message-ID: <%d.%d.%d.%d@%s>\n"
  1051.               (car time) (nth 1 time) (nth 2 time) (random 1000000)
  1052.               (system-name))))
  1053.     ;; REPLYTO environmental variable support
  1054.     ;; note that in FSF Emacs v19.29 we would initialize if the
  1055.     ;; value was t.  nil is the trigger value used now.
  1056.     (and (eq mail-default-reply-to nil)
  1057.      (setq mail-default-reply-to (getenv "REPLYTO")))
  1058.     (if mail-default-reply-to
  1059.     (insert "Reply-To: " mail-default-reply-to "\n"))
  1060.     (if mail-self-blind
  1061.     (insert "Bcc: " (user-login-name) "\n"))
  1062.     (if mail-archive-file-name
  1063.     (insert "FCC: " mail-archive-file-name "\n"))
  1064.     (if mail-default-headers
  1065.     (insert mail-default-headers))
  1066.     (if (not (= (preceding-char) ?\n))
  1067.     (insert ?\n))
  1068.     (insert mail-header-separator "\n")
  1069.     (cond ((stringp mail-signature)
  1070.        (save-excursion
  1071.          (insert mail-signature)))
  1072.       ((eq mail-signature t)
  1073.        (save-excursion
  1074.          (insert "\n-- \n")
  1075.          (insert-file-contents (or (and (boundp 'mail-signature-file)
  1076.                         (stringp mail-signature-file)
  1077.                         mail-signature-file)
  1078.                        "~/.signature")))))
  1079.     ;; move this buffer to the head of the buffer list so window
  1080.     ;; config stuff will select it as the composition buffer.
  1081.     (vm-unbury-buffer (current-buffer))
  1082.     ;; make a new frame if the user wants it.
  1083.     (if (and vm-mutable-frames vm-frame-per-composition
  1084.          (vm-multiple-frames-possible-p))
  1085.     (progn
  1086.       (vm-goto-new-frame 'composition)
  1087.       (vm-set-hooks-for-frame-deletion)))
  1088.     ;; now do window configuration
  1089.     (vm-display (current-buffer) t
  1090.         '(vm-mail
  1091.           vm-mail-other-frame
  1092.           vm-mail-other-window
  1093.           vm-reply
  1094.           vm-reply-other-frame
  1095.           vm-reply-include-text
  1096.           vm-reply-include-text-other-frame
  1097.           vm-followup
  1098.           vm-followup-other-frame
  1099.           vm-followup-include-text
  1100.           vm-followup-include-text-other-frame
  1101.           vm-send-digest
  1102.           vm-send-digest-other-frame
  1103.           vm-send-rfc934-digest
  1104.           vm-send-rfc934-digest-other-frame
  1105.           vm-send-rfc1153-digest
  1106.           vm-send-rfc1153-digest-other-frame
  1107.           vm-send-mime-digest
  1108.           vm-send-mime-digest-other-frame
  1109.           vm-forward-message
  1110.           vm-forward-message-other-frame
  1111.           vm-forward-message-all-headers
  1112.           vm-forward-message-all-headers-other-frame
  1113.           vm-resend-message
  1114.           vm-resend-message-other-frame
  1115.           vm-resend-bounced-message
  1116.           vm-resend-bounced-message-other-frame)
  1117.         (list this-command 'composing-message))
  1118.     (if (null to)
  1119.     (mail-position-on-field "To"))
  1120.     (run-hooks 'mail-setup-hook)))
  1121.  
  1122. (defun vm-reply-other-frame (count)
  1123.   "Like vm-reply, but run in a newly created frame."
  1124.   (interactive "p")
  1125.   (if (vm-multiple-frames-possible-p)
  1126.       (vm-goto-new-frame 'composition))
  1127.   (let ((vm-frame-per-composition nil)
  1128.     (vm-search-other-frames nil))
  1129.     (vm-reply count))
  1130.   (if (vm-multiple-frames-possible-p)
  1131.       (vm-set-hooks-for-frame-deletion)))
  1132.  
  1133. (defun vm-reply-include-text-other-frame (count)
  1134.   "Like vm-reply-include-text, but run in a newly created frame."
  1135.   (interactive "p")
  1136.   (if (vm-multiple-frames-possible-p)
  1137.       (vm-goto-new-frame 'composition))
  1138.   (let ((vm-frame-per-composition nil)
  1139.     (vm-search-other-frames nil))
  1140.     (vm-reply-include-text count))
  1141.   (if (vm-multiple-frames-possible-p)
  1142.       (vm-set-hooks-for-frame-deletion)))
  1143.  
  1144. (defun vm-followup-other-frame (count)
  1145.   "Like vm-followup, but run in a newly created frame."
  1146.   (interactive "p")
  1147.   (if (vm-multiple-frames-possible-p)
  1148.       (vm-goto-new-frame 'composition))
  1149.   (let ((vm-frame-per-composition nil)
  1150.     (vm-search-other-frames nil))
  1151.     (vm-followup count))
  1152.   (if (vm-multiple-frames-possible-p)
  1153.       (vm-set-hooks-for-frame-deletion)))
  1154.  
  1155. (defun vm-followup-include-text-other-frame (count)
  1156.   "Like vm-followup-include-text, but run in a newly created frame."
  1157.   (interactive "p")
  1158.   (if (vm-multiple-frames-possible-p)
  1159.       (vm-goto-new-frame 'composition))
  1160.   (let ((vm-frame-per-composition nil)
  1161.     (vm-search-other-frames nil))
  1162.     (vm-followup-include-text count))
  1163.   (if (vm-multiple-frames-possible-p)
  1164.       (vm-set-hooks-for-frame-deletion)))
  1165.  
  1166. (defun vm-forward-message-all-headers-other-frame ()
  1167.   "Like vm-forward-message-all-headers, but run in a newly created frame."
  1168.   (interactive)
  1169.   (if (vm-multiple-frames-possible-p)
  1170.       (vm-goto-new-frame 'composition))
  1171.   (let ((vm-frame-per-composition nil)
  1172.     (vm-search-other-frames nil))
  1173.     (vm-forward-message-all-headers))
  1174.   (if (vm-multiple-frames-possible-p)
  1175.       (vm-set-hooks-for-frame-deletion)))
  1176.  
  1177. (defun vm-forward-message-other-frame ()
  1178.   "Like vm-forward-message, but run in a newly created frame."
  1179.   (interactive)
  1180.   (if (vm-multiple-frames-possible-p)
  1181.       (vm-goto-new-frame 'composition))
  1182.   (let ((vm-frame-per-composition nil)
  1183.     (vm-search-other-frames nil))
  1184.     (vm-forward-message))
  1185.   (if (vm-multiple-frames-possible-p)
  1186.       (vm-set-hooks-for-frame-deletion)))
  1187.  
  1188. (defun vm-resend-message-other-frame ()
  1189.   "Like vm-resend-message, but run in a newly created frame."
  1190.   (interactive)
  1191.   (if (vm-multiple-frames-possible-p)
  1192.       (vm-goto-new-frame 'composition))
  1193.   (let ((vm-frame-per-composition nil)
  1194.     (vm-search-other-frames nil))
  1195.     (vm-resend-message))
  1196.   (if (vm-multiple-frames-possible-p)
  1197.       (vm-set-hooks-for-frame-deletion)))
  1198.  
  1199. (defun vm-resend-bounced-message-other-frame ()
  1200.   "Like vm-resend-bounced-message, but run in a newly created frame."
  1201.   (interactive)
  1202.   (if (vm-multiple-frames-possible-p)
  1203.       (vm-goto-new-frame 'composition))
  1204.   (let ((vm-frame-per-composition nil)
  1205.     (vm-search-other-frames nil))
  1206.     (vm-resend-bounced-message))
  1207.   (if (vm-multiple-frames-possible-p)
  1208.       (vm-set-hooks-for-frame-deletion)))
  1209.  
  1210. (defun vm-send-digest-other-frame (&optional prefix)
  1211.   "Like vm-send-digest, but run in a newly created frame."
  1212.   (interactive "P")
  1213.   (if (vm-multiple-frames-possible-p)
  1214.       (vm-goto-new-frame 'composition))
  1215.   (let ((vm-frame-per-composition nil)
  1216.     (vm-search-other-frames nil))
  1217.     (vm-send-digest prefix))
  1218.   (if (vm-multiple-frames-possible-p)
  1219.       (vm-set-hooks-for-frame-deletion)))
  1220.  
  1221. (defun vm-send-rfc934-digest-other-frame (&optional prefix)
  1222.   "Like vm-send-rfc934-digest, but run in a newly created frame."
  1223.   (interactive "P")
  1224.   (if (vm-multiple-frames-possible-p)
  1225.       (vm-goto-new-frame 'composition))
  1226.   (let ((vm-frame-per-composition nil)
  1227.     (vm-search-other-frames nil))
  1228.     (vm-send-rfc934-digest prefix))
  1229.   (if (vm-multiple-frames-possible-p)
  1230.       (vm-set-hooks-for-frame-deletion)))
  1231.  
  1232. (defun vm-send-rfc1153-digest-other-frame (&optional prefix)
  1233.   "Like vm-send-rfc1153-digest, but run in a newly created frame."
  1234.   (interactive "P")
  1235.   (if (vm-multiple-frames-possible-p)
  1236.       (vm-goto-new-frame 'composition))
  1237.   (let ((vm-frame-per-composition nil)
  1238.     (vm-search-other-frames nil))
  1239.     (vm-send-rfc1153-digest prefix))
  1240.   (if (vm-multiple-frames-possible-p)
  1241.       (vm-set-hooks-for-frame-deletion)))
  1242.  
  1243. (defun vm-send-mime-digest-other-frame (&optional prefix)
  1244.   "Like vm-send-mime-digest, but run in a newly created frame."
  1245.   (interactive "P")
  1246.   (if (vm-multiple-frames-possible-p)
  1247.       (vm-goto-new-frame 'composition))
  1248.   (let ((vm-frame-per-composition nil)
  1249.     (vm-search-other-frames nil))
  1250.     (vm-send-mime-digest prefix))
  1251.   (if (vm-multiple-frames-possible-p)
  1252.       (vm-set-hooks-for-frame-deletion)))
  1253.